home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _8917ff653f64c69ce77e80698175ddbd < prev    next >
Encoding:
Text File  |  2002-06-17  |  8.0 KB  |  273 lines
  1. # NOTE: Derived from ../LIB\Getopt\Long.pm.
  2. # Changes made here will be lost when autosplit is run again.
  3. # See AutoSplit.pm.
  4. package Getopt::Long;
  5.  
  6. #line 656 "../LIB\Getopt\Long.pm (autosplit into ..\lib\auto\Getopt\Long\FindOption.al)"
  7. # Option lookup.
  8. sub FindOption ($$$$$$$) {
  9.  
  10.     # returns (1, $opt, $arg, $dsttype, $incr, $key) if okay,
  11.     # returns (0) otherwise.
  12.  
  13.     my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_;
  14.     my $key;            # hash key for a hash option
  15.     my $arg;
  16.  
  17.     print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug;
  18.  
  19.     return 0 unless $opt =~ /^$prefix(.*)$/s;
  20.     return 0 if $opt eq "-" && !defined $opctl->{""};
  21.  
  22.     $opt = $+;
  23.     my ($starter) = $1;
  24.  
  25.     print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
  26.  
  27.     my $optarg = undef;    # value supplied with --opt=value
  28.     my $rest = undef;    # remainder from unbundling
  29.  
  30.     # If it is a long option, it may include the value.
  31.     if (($starter eq "--" || ($getopt_compat && !$bundling))
  32.     && $opt =~ /^([^=]+)=(.*)$/s ) {
  33.     $opt = $1;
  34.     $optarg = $2;
  35.     print STDERR ("=> option \"", $opt,
  36.               "\", optarg = \"$optarg\"\n") if $debug;
  37.     }
  38.  
  39.     #### Look it up ###
  40.  
  41.     my $tryopt = $opt;        # option to try
  42.     my $optbl = $opctl;        # table to look it up (long names)
  43.     my $type;
  44.     my $dsttype = '';
  45.     my $incr = 0;
  46.  
  47.     if ( $bundling && $starter eq '-' ) {
  48.     # Unbundle single letter option.
  49.     $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : "";
  50.     $tryopt = substr ($tryopt, 0, 1);
  51.     $tryopt = lc ($tryopt) if $ignorecase > 1;
  52.     print STDERR ("=> $starter$tryopt unbundled from ",
  53.               "$starter$tryopt$rest\n") if $debug;
  54.     $rest = undef unless $rest ne '';
  55.     $optbl = $bopctl;    # look it up in the short names table
  56.  
  57.     # If bundling == 2, long options can override bundles.
  58.     if ( $bundling == 2 and
  59.          defined ($rest) and
  60.          defined ($type = $opctl->{$tryopt.$rest}) ) {
  61.         print STDERR ("=> $starter$tryopt rebundled to ",
  62.               "$starter$tryopt$rest\n") if $debug;
  63.         $tryopt .= $rest;
  64.         undef $rest;
  65.     }
  66.     }
  67.  
  68.     # Try auto-abbreviation.
  69.     elsif ( $autoabbrev ) {
  70.     # Downcase if allowed.
  71.     $tryopt = $opt = lc ($opt) if $ignorecase;
  72.     # Turn option name into pattern.
  73.     my $pat = quotemeta ($opt);
  74.     # Look up in option names.
  75.     my @hits = grep (/^$pat/, @{$names});
  76.     print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
  77.               "out of ", scalar(@{$names}), "\n") if $debug;
  78.  
  79.     # Check for ambiguous results.
  80.     unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
  81.         # See if all matches are for the same option.
  82.         my %hit;
  83.         foreach ( @hits ) {
  84.         $_ = $aliases->{$_} if defined $aliases->{$_};
  85.         $hit{$_} = 1;
  86.         }
  87.         # Now see if it really is ambiguous.
  88.         unless ( keys(%hit) == 1 ) {
  89.         return (0) if $passthrough;
  90.         warn ("Option ", $opt, " is ambiguous (",
  91.               join(", ", @hits), ")\n");
  92.         $error++;
  93.         undef $opt;
  94.         return (1, $opt,$arg,$dsttype,$incr,$key);
  95.         }
  96.         @hits = keys(%hit);
  97.     }
  98.  
  99.     # Complete the option name, if appropriate.
  100.     if ( @hits == 1 && $hits[0] ne $opt ) {
  101.         $tryopt = $hits[0];
  102.         $tryopt = lc ($tryopt) if $ignorecase;
  103.         print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
  104.         if $debug;
  105.     }
  106.     }
  107.  
  108.     # Map to all lowercase if ignoring case.
  109.     elsif ( $ignorecase ) {
  110.     $tryopt = lc ($opt);
  111.     }
  112.  
  113.     # Check validity by fetching the info.
  114.     $type = $optbl->{$tryopt} unless defined $type;
  115.     unless  ( defined $type ) {
  116.     return (0) if $passthrough;
  117.     warn ("Unknown option: ", $opt, "\n");
  118.     $error++;
  119.     return (1, $opt,$arg,$dsttype,$incr,$key);
  120.     }
  121.     # Apparently valid.
  122.     $opt = $tryopt;
  123.     print STDERR ("=> found \"$type\" for \"", $opt, "\"\n") if $debug;
  124.  
  125.     #### Determine argument status ####
  126.  
  127.     # If it is an option w/o argument, we're almost finished with it.
  128.     if ( $type eq '' || $type eq '!' || $type eq '+' ) {
  129.     if ( defined $optarg ) {
  130.         return (0) if $passthrough;
  131.         warn ("Option ", $opt, " does not take an argument\n");
  132.         $error++;
  133.         undef $opt;
  134.     }
  135.     elsif ( $type eq '' || $type eq '+' ) {
  136.         $arg = 1;        # supply explicit value
  137.         $incr = $type eq '+';
  138.     }
  139.     else {
  140.         substr ($opt, 0, 2) = ''; # strip NO prefix
  141.         $arg = 0;        # supply explicit value
  142.     }
  143.     unshift (@ARGV, $starter.$rest) if defined $rest;
  144.     return (1, $opt,$arg,$dsttype,$incr,$key);
  145.     }
  146.  
  147.     # Get mandatory status and type info.
  148.     my $mand;
  149.     ($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/;
  150.  
  151.     # Check if there is an option argument available.
  152.     if ( $gnu_compat ) {
  153.     return (1, $opt, $optarg, $dsttype, $incr, $key)
  154.       if defined $optarg;
  155.     return (1, $opt, $type eq "s" ? '' : 0, $dsttype, $incr, $key)
  156.       if $mand eq ':';
  157.     }
  158.  
  159.     # Check if there is an option argument available.
  160.     if ( defined $optarg
  161.      ? ($optarg eq '')
  162.      : !(defined $rest || @ARGV > 0) ) {
  163.     # Complain if this option needs an argument.
  164.     if ( $mand eq "=" ) {
  165.         return (0) if $passthrough;
  166.         warn ("Option ", $opt, " requires an argument\n");
  167.         $error++;
  168.         undef $opt;
  169.     }
  170.     return (1, $opt, $type eq "s" ? '' : 0, $dsttype, $incr, $key);
  171.     }
  172.  
  173.     # Get (possibly optional) argument.
  174.     $arg = (defined $rest ? $rest
  175.         : (defined $optarg ? $optarg : shift (@ARGV)));
  176.  
  177.     # Get key if this is a "name=value" pair for a hash option.
  178.     $key = undef;
  179.     if ($dsttype eq '%' && defined $arg) {
  180.     ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2) : ($arg, 1);
  181.     }
  182.  
  183.     #### Check if the argument is valid for this option ####
  184.  
  185.     if ( $type eq "s" ) {    # string
  186.     # A mandatory string takes anything.
  187.     return (1, $opt,$arg,$dsttype,$incr,$key) if $mand eq "=";
  188.  
  189.     # An optional string takes almost anything.
  190.     return (1, $opt,$arg,$dsttype,$incr,$key)
  191.       if defined $optarg || defined $rest;
  192.     return (1, $opt,$arg,$dsttype,$incr,$key) if $arg eq "-"; # ??
  193.  
  194.     # Check for option or option list terminator.
  195.     if ($arg eq $argend ||
  196.         $arg =~ /^$prefix.+/) {
  197.         # Push back.
  198.         unshift (@ARGV, $arg);
  199.         # Supply empty value.
  200.         $arg = '';
  201.     }
  202.     }
  203.  
  204.     elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
  205.     if ( $bundling && defined $rest && $rest =~ /^([-+]?[0-9]+)(.*)$/s ) {
  206.         $arg = $1;
  207.         $rest = $2;
  208.         unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
  209.     }
  210.     elsif ( $arg !~ /^[-+]?[0-9]+$/ ) {
  211.         if ( defined $optarg || $mand eq "=" ) {
  212.         if ( $passthrough ) {
  213.             unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
  214.               unless defined $optarg;
  215.             return (0);
  216.         }
  217.         warn ("Value \"", $arg, "\" invalid for option ",
  218.               $opt, " (number expected)\n");
  219.         $error++;
  220.         undef $opt;
  221.         # Push back.
  222.         unshift (@ARGV, $starter.$rest) if defined $rest;
  223.         }
  224.         else {
  225.         # Push back.
  226.         unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
  227.         # Supply default value.
  228.         $arg = 0;
  229.         }
  230.     }
  231.     }
  232.  
  233.     elsif ( $type eq "f" ) { # real number, int is also ok
  234.     # We require at least one digit before a point or 'e',
  235.     # and at least one digit following the point and 'e'.
  236.     # [-]NN[.NN][eNN]
  237.     if ( $bundling && defined $rest &&
  238.          $rest =~ /^([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) {
  239.         $arg = $1;
  240.         $rest = $+;
  241.         unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
  242.     }
  243.     elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) {
  244.         if ( defined $optarg || $mand eq "=" ) {
  245.         if ( $passthrough ) {
  246.             unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
  247.               unless defined $optarg;
  248.             return (0);
  249.         }
  250.         warn ("Value \"", $arg, "\" invalid for option ",
  251.               $opt, " (real number expected)\n");
  252.         $error++;
  253.         undef $opt;
  254.         # Push back.
  255.         unshift (@ARGV, $starter.$rest) if defined $rest;
  256.         }
  257.         else {
  258.         # Push back.
  259.         unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
  260.         # Supply default value.
  261.         $arg = 0.0;
  262.         }
  263.     }
  264.     }
  265.     else {
  266.     Croak ("GetOpt::Long internal error (Can't happen)\n");
  267.     }
  268.     return (1, $opt, $arg, $dsttype, $incr, $key);
  269. }
  270.  
  271. # end of Getopt::Long::FindOption
  272. 1;
  273.